home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / DELPHI / QSORT.ZIP / SORT1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-12-05  |  6.9 KB  |  257 lines
  1. {*************************************************************************
  2. * This is a small example application which demonstrates the use of
  3. * the QSort procedure to sort the contents of a Listbox.
  4. *
  5. * Developed Oct 95 by Barry Schlereth
  6. *
  7. *                  ??? WHY ???
  8. *
  9. * The sorted parameter of a Listbox is nice, but what if you want to
  10. * sort the strings by their numerical representation not alphabetically?
  11. * Or, maybe you have a table and you would like to sort the rows of the
  12. * table according to the floating point numbers displayed in one column.
  13. *
  14. * That is what this example shows. I hope you find it useful.
  15. *
  16. * This example can be freely distributed. Be sure to follow the
  17. * copyrights shown below.
  18. *
  19. *
  20. * If you feel very appreciative, a small donation - 1 dollar or a couple
  21. * cereal coupons (Special K, Corn Flakes, Cheerios) - may be sent to:
  22. *
  23. *     Barry
  24. *     Box 176
  25. *     Syracuse, NY  13215
  26. *
  27. *************************************************************************}
  28.  
  29. unit Sort1;
  30.  
  31. interface
  32.  
  33. uses
  34.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  35.   Forms, Dialogs, StdCtrls;
  36.  
  37. type
  38.   TForm1 = class(TForm)
  39.     DataBox1: TListBox;
  40.     DataBox2: TListBox;
  41.     BtnSort: TButton;
  42.     BtnInit: TButton;
  43.     Label1: TLabel;
  44.     Label2: TLabel;
  45.     BtnQSort: TButton;
  46.     EdPts: TEdit;
  47.     Label3: TLabel;
  48.     Label4: TLabel;
  49.     procedure BtnInitClick(Sender: TObject);
  50.     procedure BtnSortClick(Sender: TObject);
  51.     procedure BtnQSortClick(Sender: TObject);
  52.   private
  53.     { Private declarations }
  54.   public
  55.     { Public declarations }
  56.   end;
  57.  
  58. var
  59.   Form1: TForm1;
  60.  
  61.   procedure QSort(var a: array of Integer; const lo0, hi0: Integer);
  62.   function Compare (const i, j: Integer) : Integer;
  63.  
  64. implementation
  65.  
  66. {$R *.DFM}
  67.  
  68. procedure TForm1.BtnInitClick(Sender: TObject);
  69. var
  70.   i : Integer;
  71.   f : Single;
  72. begin
  73.   Label4.Caption := 'Initializing';
  74.   Application.ProcessMessages;
  75.  
  76.   DataBox1.Items.Clear;
  77.   DataBox2.Items.Clear;
  78.   DataBox1.Sorted := False;
  79.   DataBox2.Sorted := False;
  80.   Application.ProcessMessages;
  81.  
  82.   if (StrToInt(EdPts.Text) > 5000) then begin
  83.     EdPts.Text := '5000';
  84.     Application.ProcessMessages;
  85.   end;
  86.  
  87.   for i:=StrToInt(EdPts.Text) downto 1 do begin
  88.     f := i;
  89.     DataBox1.Items.Add(FloatToStrF(f, ffFixed, 10, 1));
  90.   end;
  91.  
  92.   BtnSort.Enabled := True;
  93.   BtnQSort.Enabled := True;
  94.  
  95.   Label4.Caption := '';
  96. end;
  97.  
  98. procedure TForm1.BtnSortClick(Sender: TObject);
  99. begin
  100.   Label4.Caption := 'Copying';
  101.   Application.ProcessMessages;
  102.   DataBox2.Items.Clear;
  103.   DataBox2.Sorted := False;
  104.   DataBox2.Items.AddStrings(DataBox1.Items);
  105.  
  106.   Label4.Caption := 'Sorting';
  107.   Application.ProcessMessages;
  108.   DataBox2.Sorted := True;
  109.  
  110.   Label4.Caption := '';
  111. end;
  112.  
  113. procedure TForm1.BtnQSortClick(Sender: TObject);
  114. type
  115.   IdxArray = array [0..4999] of Integer;
  116. Var
  117.   idx : ^IdxArray;
  118.   i, n : Integer;
  119. begin
  120.   Label4.Caption := 'Initialize';
  121.   Application.ProcessMessages;
  122.  
  123.   DataBox2.Items.Clear;
  124.   DataBox2.Sorted := False;
  125.   Application.ProcessMessages;
  126.  
  127.   New(idx);
  128.  
  129.   n := DataBox1.Items.Count;
  130.  
  131.   for i:=0 to n-1 do Idx^[i] := i;
  132.  
  133.   Label4.Caption := 'Quick Sort';
  134.   Application.ProcessMessages;
  135.  
  136.   QSort(Idx^, 0, n-1);
  137.  
  138.   Label4.Caption := 'Display';
  139.   Application.ProcessMessages;
  140.  
  141.   for i := 0 to n-1 do
  142.     DataBox2.Items.Add(DataBox1.Items[Idx^[i]]);
  143.   Application.ProcessMessages;
  144.  
  145.   Dispose(Idx);
  146.  
  147.   Label4.Caption := '';
  148. end;
  149.  
  150. {********************************************************************
  151. * QSort - Quick Sort
  152. * Adapted for Delphi Pascal by Barry Schlereth   Oct 95
  153. *
  154. * Permission to use, copy, modify, and distribute this software
  155. * and its documentation for NON-COMMERCIAL purposes and without
  156. * fee is hereby granted provided that this copyright notice and the
  157. * original copyright appears in all copies. (Also see below)
  158. *
  159. * THIS SOURCE CODE IS SUPPLIED "AS IS" AND IS NOT WARRANTIED IN ANY
  160. * WAY, EXPRESS OR IMPLIED.
  161. *
  162. * Original "C" implementation by James Gosling (see below)
  163. *
  164. * The QSort procedure takes three parameters:
  165. *   a   - an integer array of indices.
  166. *   lo0 - the lower index of a to sort.
  167. *   hi0 - the top index of a to sort (Count of a -1)
  168. *
  169. * Qsort requires a companion function, Compare(i, j), which tells
  170. * it how to sort the indices. Compare returns -1, 0, +1, (<, =, >)
  171. * depending on the relationship of a[i] to a[j]. In this example
  172. * Compare(i, j) compares the StrToFloat of Item[i] to Item[j] in
  173. * the ListBox (DataBox1).
  174. *
  175. * QSort is recursive - watch your stack when sorting large arrays.
  176. *
  177. *-----------------------------------------------------------------
  178. * Quick Sort Algorithm
  179. * original implementation by James Gosling v1.6 95/01/31
  180. *
  181. * Copyright (c) 1994 Sun Microsystems, Inc. All Rights Reserved.
  182. *
  183. * Permission to use, copy, modify, and distribute this software
  184. * and its documentation for NON-COMMERCIAL purposes and without
  185. * fee is hereby granted provided that this copyright notice
  186. * appears in all copies. Please refer to the file "copyright.html"
  187. * for further important copyright and licensing information.
  188. *
  189. * SUN MAKES NO REPRESENTATIONS OR WARRANTIES ABOUT THE SUITABILITY OF
  190. * THE SOFTWARE, EITHER EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED
  191. * TO THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
  192. * PARTICULAR PURPOSE, OR NON-INFRINGEMENT. SUN SHALL NOT BE LIABLE FOR
  193. * ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
  194. * DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES.
  195. *---------------------------------------------------------------------}
  196.  
  197. procedure QSort(var a: array of Integer; const lo0, hi0: Integer);
  198. var
  199.   lo, hi, mid, t : Integer;
  200. begin
  201.   lo := lo0;
  202.   hi := hi0;
  203.   Application.ProcessMessages;
  204.  
  205.   if (lo < hi) then begin
  206.     mid := (lo + hi) div 2;
  207.  
  208.     while (lo < hi) do begin
  209.       while ((lo<hi) and (Compare(a[lo], a[mid]) < 0)) do inc(lo);
  210.  
  211.       while ((lo<hi) and (Compare(a[hi], a[mid]) > 0)) do dec(hi);
  212.  
  213.       if (lo < hi) then begin
  214.         t := a[lo];
  215.         a[lo] := a[hi];
  216.         a[hi] := t;
  217.       end;
  218.     end;
  219.  
  220.     if (hi < lo) then begin
  221.       t := hi;
  222.       hi := lo;
  223.       lo := t;
  224.     end;
  225.  
  226.     QSort(a, lo0, lo);
  227.     if (lo = lo0) then t := lo+1 else t := lo;
  228.     QSort(a, t, hi0);
  229.   end;
  230. end;
  231.  
  232. { This is the companion function Compare. It provides the relationship
  233.   comparison for QSort. The indicies (i, j) can index into any type of
  234.   Array, StringList, etc. In real-life you would speed things alot by
  235.   by building and sorting a dummy floating point array derived from
  236. the
  237.   values in DataBox1.Items instead of converting with each comparison
  238.   as is shown in this example! }
  239.  
  240. function Compare (const i, j: Integer) : Integer;
  241. var
  242.   f, g : Single;
  243. begin
  244.   f := StrToFloat(Form1.DataBox1.Items[i]);
  245.   g := StrToFloat(Form1.DataBox1.Items[j]);
  246.  
  247.   if (f < g) then Compare := -1
  248.   else if (f > g) then Compare := 1
  249.   else Compare := 0;
  250. end;
  251.  
  252. end.
  253.  
  254.  
  255.  
  256.  
  257.